#lang racket


(require mysterx)

(require "../base/main.rkt"
         "../proxies/main.rkt")

(provide (struct-out com-exn)
         load-rhino-com
         
         ; constants
         create-preview-image-honor-flag
         create-preview-image-draw-flag
         create-preview-image-ghosted-flag
         
         domain-direction-u
         domain-direction-v
         
         knot-style-uniform-knots
         knot-style-chord-length-spacing
         knot-style-sqrt
         knot-style-periodic-uniform-spacing
         knot-style-periodic-chord-length-spacing
         knot-style-periodic-sqrt
         
         loft-type-normal
         loft-type-loose
         loft-type-straight
         loft-type-tight
         loft-type-developable
         
         loft-style-none
         loft-style-rebuild
         loft-style-refit
         
         optional
         
         view-display-mode-wireframe
         view-display-mode-shaded
         view-display-mode-render-preview
         
         view-perspective
         
         view-projection-mode-parallel
         view-projection-mode-perspective
         
         ; methods
         add-arc
         add-box
         add-circle
         add-cone
         add-cylinder
         add-edge-srf
         add-ellipse
         add-hatch
         add-interp-curve
         add-layer
         add-line
         add-loft-srf
         all-objects
         add-planar-srf
         add-plane-surface
         add-point
         add-polyline
         add-sphere
         add-srf-contour-crvs
         add-srf-pt
         add-srf-section-crvs
         add-text
         
         boolean-difference
         boolean-intersection
         boolean-union
         
         bounding-box
         
         cap-planar-holes
         
         circle-center-point
         circle-radius
         
         clear-command-history
         close-curve
         
         command
         
         copy-object
         copy-objects
         
         create-preview-image
         
         create-solid
         
         current-layer
         
         curve-boolean-difference
         curve-boolean-intersection
         curve-boolean-union
         curve-domain
         curve-end-point
         curve-perp-frame
         curve-frame
         curve-normal
         curve-points
         curve-start-point
         
         delete-layer
         delete-object
         delete-objects
         
         duplicate-edge-curves
         duplicate-surface-border
         
         enable-redraw
         
         extrude-curve
         extrude-curve-point
         extrude-curve-straight
         extrude-surface
         
         get-object
         get-point
         intersect-breps
         
         is-circle?
         is-curve?
         is-curve-closable?
         is-curve-closed?
         is-layer?
         is-line?
         is-object?
         is-object-in-box?
         is-object-solid?
         is-point?
         is-polycurve?
         is-polysurface?
         is-surface?
         
         last-created-objects
         
         join-curves
         join-surfaces
         
         move-object
         move-objects
         offset-surface
         
         plane-from-frame
         plane-from-normal
         plane-from-points
         point-coordinates
         
         rotate-object
         rotate-objects
         
         scale-object
         scale-objects
         
         select-object
         select-objects
         selected-objects
         
         split-brep
         
         surface-curvature
         surface-domain
         
         sweep1
         
         transform-object
         transform-objects
         
         unselect-all-objects
         unselect-object
         unselect-objects
         
         view-camera-lens
         view-camera-target
         view-display-mode
         view-projection
         view-radius
         view-size
         
         world-xy-plane
         world-yz-plane
         world-zx-plane
         
         zoom-extents
         zoom-selected)


; exception

(struct com-exn exn:fail ())

(define (raise-com-exn msg)
  (raise (com-exn msg (current-continuation-marks))))


; constants

(define create-preview-image-honor-flag 1)
(define create-preview-image-draw-flag 2)
(define create-preview-image-ghosted-flag 4)

(define domain-direction-u 0)
(define domain-direction-v 1)

(define knot-style-uniform-knots 0)
(define knot-style-chord-length-spacing 1)
(define knot-style-sqrt 2)
(define knot-style-periodic-uniform-spacing 3)
(define knot-style-periodic-chord-length-spacing 4)
(define knot-style-periodic-sqrt 5)

(define loft-type-normal 0)
(define loft-type-loose 1)
(define loft-type-straight 2)
(define loft-type-tight 3)
(define loft-type-developable 4)

(define loft-style-none 0)
(define loft-style-rebuild 1)
(define loft-style-refit 2)

(define optional com-omit)

(define view-display-mode-wireframe 0)
(define view-display-mode-shaded 1)
(define view-display-mode-render-preview 2)

(define view-perspective "Perspective")

(define view-projection-mode-parallel 1)
(define view-projection-mode-perspective 2)


; initialization

(define rhino-com-msg "Waiting for Rhinoceros3D to be ready...")

(define (rhino-invoke name . args)
  (apply com-invoke rhino-coobject name args))

(define (rhino-check-invoke name . args)
  (let ((val (apply rhino-invoke name args)))
    (if (void? val)
        (raise-com-exn (format "COM error. Got no results from ~A: ~A" name args))
        val)))

(define (rhino-check-invoke-boolean name . args)
  (let ((val (apply rhino-invoke name args)))
    (cond ((or (void? val) (not (boolean? val)) (not val))
           (raise-com-exn (format "~A: ~A" name args)))
          (else
           val))))

(define (rhino-get-property . args)
  (apply com-get-property args))

(define (rhino-set-property! . args)
  (apply com-set-property! args))


(define rhino-coclass #f)
(define rhino-coobject #f)


(define (load-rhino-com)
  (set! rhino-coclass
        (let ((coclass-name "Rhino4.Interface"))
          (with-handlers ((exn?
                           (λ (e)
                             (displayln "Starting Rhinoceros 3D...")
                             (cci/coclass coclass-name))))
            (gao/coclass coclass-name))))
  (rhino-set-property! rhino-coclass "Visible" true)
  ; edit: make better
  (set! rhino-coobject
        (try-void-connection
         rhino-com-msg
         (λ () (com-invoke rhino-coclass "GetScriptObject")))))


; marshaling

; info: incoherency: rhino returns nested planes but expects flat planes
(define (flat-plane<-matrix m)
  (vector-map
   real<-number
   (vector-append
    (vector-drop-right (m-column m 3) 1)
    (vector-drop-right (m-column m 0) 1)
    (vector-drop-right (m-column m 1) 1)
    (vector-drop-right (m-column m 2) 1))))

; info: incoherency: rhino returns nested planes but expects flat planes
(define (matrix<-nested-plane pl)
  (apply m-cols (list-rotate-left (vector->list pl) 1)))


; methods

(define (add-arc plane radius angle)
  (rhino-check-invoke
   "AddArc"
   (flat-plane<-matrix plane)
   (real<-number radius)
   (real<-number angle)))

(define (add-box corners)
  (rhino-check-invoke
   "AddBox"
   (vector<real><-list<number> corners)))

(define (add-circle plane radius)
  (rhino-check-invoke
   "AddCircle"
   (flat-plane<-matrix plane)
   (real<-number radius)))

(define (add-cone base height radius cap?)
  (rhino-check-invoke
   "AddCone"
   (vector<real><-coord base)
   (vector<real><-coord height)
   (real<-number radius)
   cap?))

(define (add-cylinder base height radius cap?)
  (rhino-check-invoke
   "AddCylinder"
   (vector<real><-coord base)
   (vector<real><-coord height)
   (real<-number radius)
   cap?))

(define (add-edge-srf objects)
  (rhino-check-invoke "AddEdgeSrf" objects))

(define (add-ellipse plane x-radius y-radius)
  (rhino-check-invoke
   "AddEllipse"
   (flat-plane<-matrix plane)
   (real<-number x-radius)
   (real<-number y-radius)))

(define add-hatch
  (case-lambda
    ((curve)
     (rhino-check-invoke "AddHatch" curve))
    ((curve hatch)
     (rhino-check-invoke "AddHatch" curve hatch))
    ((curve hatch scale)
     (rhino-check-invoke "AddHatch" curve hatch (real<-number scale)))
    ((curve hatch scale rotation)
     (rhino-check-invoke
      "AddHatch"
      curve
      hatch
      (real<-number scale)
      (real<-number rotation)))))

(define add-interp-curve
  (case-lambda
    ((points)
     (rhino-check-invoke
      "AddInterpCurve"
      (flat-vector<real><-list<coord> points)))
    ((points degree)
     (rhino-check-invoke
      "AddInterpCurve"
      (flat-vector<real><-list<coord> points)
      degree))
    ((points degree knot-style)
     (rhino-check-invoke
      "AddInterpCurve"
      (flat-vector<real><-list<coord> points)
      degree
      knot-style))
    ((points degree knot-style start-tangent)
     (rhino-check-invoke
      "AddInterpCurve"
      (flat-vector<real><-list<coord> points)
      degree
      knot-style
      (vector<real><-coord start-tangent)))
    ((points degree knot-style start-tangent end-tangent)
     (rhino-check-invoke
      "AddInterpCurve"
      (flat-vector<real><-list<coord> points)
      degree
      knot-style
      (vector<real><-coord start-tangent)
      (vector<real><-coord end-tangent)))))

; edit: color marshaling
(define add-layer
  (case-lambda
    (()
     (rhino-check-invoke "AddLayer"))
    ((layer)
     (rhino-check-invoke "AddLayer" layer))
    ((layer color)
     (rhino-check-invoke "AddLayer" layer color))
    ((layer color visible?)
     (rhino-check-invoke "AddLayer" layer color visible?))
    ((layer color visible? locked?)
     (rhino-check-invoke "AddLayer" layer color visible? locked?))
    ((layer color visible? locked? parent)
     (rhino-check-invoke "AddLayer" layer color visible? locked? parent))))

(define (add-line start end)
  (rhino-check-invoke
   "AddLine"
   (vector<real><-coord start)
   (vector<real><-coord end)))

; edit: incomplete API
(define add-loft-srf
  (case-lambda
    ((objects)
     (vector->list
      (rhino-check-invoke "AddLoftSrf" (list->vector objects))))
    ((objects closed?)
     (vector->list
      (rhino-check-invoke
       "AddLoftSrf"
       (list->vector objects)
       com-omit
       com-omit
       com-omit
       com-omit
       com-omit
       closed?)))
    ((objects type closed?)
     (vector->list
      (rhino-check-invoke
       "AddLoftSrf"
       (list->vector objects)
       com-omit
       com-omit
       type
       com-omit
       com-omit
       closed?)))
    ((objects start end type style value closed?)
     (vector->list
      (rhino-check-invoke
       "AddLoftSrf"
       (list->vector objects)
       (vector<real><-coord start)
       (vector<real><-coord end)
       type
       style
       value
       closed?)))))

(define (add-planar-srf objects)
  (vector->list
   (rhino-check-invoke "AddPlanarSrf" (list->vector objects))))

(define (add-plane-surface plane du dv)
  (rhino-check-invoke
   "AddPlaneSurface"
   (flat-plane<-matrix plane)
   (real<-number du)
   (real<-number dv)))

(define (add-point point)
  (rhino-check-invoke
   "AddPoint"
   (vector<real><-coord point)))

(define (add-polyline points)
  (rhino-check-invoke
   "AddPolyline"
   (flat-vector<real><-list<coord> points)))

(define (add-sphere center radius)
  (rhino-check-invoke
   "AddSphere"
   (vector<real><-coord center)
   (real<-number radius)))

; info: API is incomplete because the last case clashes with these
(define add-srf-contour-crvs
  (case-lambda
    ((object plane)
     (vector->list
      (rhino-check-invoke
       "AddSrfContourCrvs"
       object
       plane)))
    ((object plane interval)
     (vector->list
      (rhino-check-invoke
       "AddSrfContourCrvs"
       object
       plane
       (real<-number interval))))
    ((object start-point end-point interval)
     (vector->list
      (rhino-check-invoke
       "AddSrfContourCrvs"
       object
       (vector<real><-coord start-point)
       (vector<real><-coord end-point)
       (real<-number interval))))))

(define (add-srf-pt points)
  (rhino-check-invoke
   "AddSrfPt"
   (flat-vector<real><-list<coord> points)))

(define (add-srf-section-crvs object plane)
  (vector->list
   (rhino-check-invoke
    "AddSrfSectionCrvs"
    object
    (flat-plane<-matrix plane))))

(define add-text
  (case-lambda
    ((text plane)
     (rhino-check-invoke
      "AddText"
      text
      (flat-plane<-matrix plane)))
    ((text plane height)
     (rhino-check-invoke
      "AddText"
      text
      (flat-plane<-matrix plane)
      (real<-number height)))
    ((text plane height font)
     (rhino-check-invoke
      "AddText"
      text
      (flat-plane<-matrix plane)
      (real<-number height)
      font))
    ((text plane height font style)
     (rhino-check-invoke
      "AddText"
      text
      (flat-plane<-matrix plane)
      (real<-number height)
      font
      style))))

(define (all-objects . args)
  (with-handlers ((com-exn? (λ (e) (list))))
    (vector->list
     (match args
       ((list)
        (rhino-check-invoke "AllObjects"))
       ((list select?)
        (rhino-check-invoke "AllObjects" select?))
       ((list select? include-lights?)
        (rhino-check-invoke
         "AllObjects"
         select?
         include-lights?))
       ((list select? include-lights? include-grips?)
        (rhino-check-invoke
         "AllObjects"
         select?
         include-lights?
         include-grips?))))))

(define boolean-difference
  (case-lambda
    ((objects1 objects2)
     (vector->list
      (rhino-check-invoke
       "BooleanDifference"
       (list->vector objects1)
       (list->vector objects2))))
    ((objects1 objects2 delete?)
     (vector->list
      (rhino-check-invoke
       "BooleanDifference"
       (list->vector objects1)
       (list->vector objects2)
       delete?)))))

(define boolean-intersection
  (case-lambda
    ((objects1 objects2)
     (vector->list
      (rhino-check-invoke
       "BooleanIntersection"
       (list->vector objects1)
       (list->vector objects2))))
    ((objects1 objects2 delete?)
     (vector->list
      (rhino-check-invoke
       "BooleanIntersection"
       (list->vector objects1)
       (list->vector objects2)
       delete?)))))

(define boolean-union
  (case-lambda
    ((objects)
     (vector->list
      (rhino-check-invoke "BooleanUnion" (list->vector objects))))
    ((objects delete?)
     (vector->list
      (rhino-check-invoke "BooleanUnion" (list->vector objects) delete?)))))

; edit: incomplete API
(define (bounding-box object/objects)
  (make-bbox
   (list<coord><-vector<vector<real>>
    (if (list? object/objects)
        (rhino-check-invoke "BoundingBox" (list->vector object/objects))
        (rhino-check-invoke "BoundingBox" object/objects)))))

(define (cap-planar-holes surface)
  (rhino-check-invoke-boolean "CapPlanarHoles" surface))

(define (circle-center-point object)
  (coord-of-vector
   (rhino-check-invoke "CircleCenterPoint" object)))

(define (circle-radius object)
  (rhino-check-invoke "CircleRadius" object))

(define (clear-command-history)
  (rhino-invoke "ClearCommandHistory"))

(define close-curve
  (case-lambda
    ((object)
     (rhino-check-invoke "CloseCurve" object))
    ((object tolerance)
     (rhino-check-invoke "CloseCurve" object (real<-number tolerance)))))

(define (command command (echo? #t))
  (rhino-check-invoke "Command" command echo?))

(define copy-object
  (case-lambda
    ((object)
     (rhino-check-invoke "CopyObject" object))
    ((object translation)
     (rhino-check-invoke
      "CopyObject"
      object
      (vector<real><-coord translation)))
    ((object start end)
     (rhino-check-invoke
      "CopyObject"
      object
      (vector<real><-coord start)
      (vector<real><-coord end)))))

(define copy-objects
  (case-lambda
    ((objects translation)
     (if (empty? objects)
         (list)
         (vector->list
          (rhino-check-invoke
           "CopyObjects"
           (list->vector objects)))))
    ((objects translation)
     (if (empty? objects)
         (list)
         (vector->list
          (rhino-check-invoke
           "CopyObjects"
           (list->vector objects)
           (vector<real><-coord translation)))))
    ((objects start end)
     (if (empty? objects)
         (list)
         (vector->list
          (rhino-check-invoke
           "CopyObjects"
           (list->vector objects)
           (vector<real><-coord start)
           (vector<real><-coord end)))))))

(define create-preview-image
  (case-lambda
    ((file)
     (rhino-invoke "CreatePreviewImage" file))
    ((file view)
     (rhino-invoke "CreatePreviewImage" file view))
    ((file view size)
     (rhino-invoke "CreatePreviewImage" file view (list->vector size)))
    ((file view size flags)
     (rhino-invoke "CreatePreviewImage" file view (list->vector size) flags))
    ((file view size flags wireframe?)
     (rhino-invoke "CreatePreviewImage" file view (list->vector size) flags wireframe?))))

(define (create-solid objects (delete? #f))
  (vector->list
   (rhino-check-invoke "CreateSolid" (list->vector objects) delete?)))

(define current-layer
  (case-lambda
    (()
     (rhino-check-invoke "CurrentLayer"))
    ((layer)
     (rhino-check-invoke "CurrentLayer" layer))))

(define (curve-boolean-difference curve1 curve2)
  (vector->list
   (rhino-check-invoke "CurveBooleanDifference" curve1 curve2)))

(define (curve-boolean-intersection curve1 curve2)
  (vector->list
   (rhino-check-invoke "CurveBooleanIntersection" curve1 curve2)))

(define (curve-boolean-union curves)
  (vector->list
   (rhino-check-invoke "CurveBooleanUnion" (list->vector curves))))

(define (curve-domain object)
  (vector->list
   (rhino-check-invoke "CurveDomain" object)))

(define (curve-end-point object)
  (coord-of-vector
   (rhino-check-invoke "CurveEndPoint" object)))

(define (curve-frame curve parameter)
  (matrix<-nested-plane
   (rhino-check-invoke "CurveFrame" curve parameter)))

(define (curve-perp-frame curve parameter)
  (matrix<-nested-plane
   (rhino-check-invoke "CurvePerpFrame" curve parameter)))

(define (curve-normal object)
  (coord-of-vector
   (rhino-check-invoke "CurveNormal" object)))

(define (curve-points object)
  (list<coord><-vector<vector<real>>
   (rhino-check-invoke "CurvePoints" object)))

(define (curve-start-point object)
  (coord-of-vector
   (rhino-check-invoke "CurveStartPoint" object)))

(define (delete-layer layer)
  (rhino-check-invoke "DeleteLayer" layer))

(define (delete-object object)
  (rhino-check-invoke "DeleteObject" object))

(define (delete-objects objects)
  (if (empty? objects)
      0
      (rhino-check-invoke "DeleteObjects" (list->vector objects))))

(define duplicate-edge-curves
  (case-lambda
    ((object)
     (vector->list
      (rhino-check-invoke "DuplicateEdgeCurves" object)))
    ((object select?)
     (vector->list
      (rhino-check-invoke "DuplicateEdgeCurves" object select?)))))

(define (duplicate-surface-border object)
  (vector->list
   (rhino-check-invoke "DuplicateSurfaceBorder" object)))

(define (enable-redraw redraw)
  (rhino-invoke "EnableRedraw" redraw))

(define (extrude-curve curve path)
  (rhino-check-invoke "ExtrudeCurve" curve path))

(define (extrude-curve-point curve point)
  (rhino-check-invoke
   "ExtrudeCurvePoint"
   curve
   (vector<real><-coord point)))

(define (extrude-curve-straight curve start-point end-point)
  (rhino-check-invoke
   "ExtrudeCurveStraight"
   curve
   (vector<real><-coord start-point)
   (vector<real><-coord end-point)))

(define extrude-surface
  (case-lambda
    ((surface curve)
     (rhino-check-invoke "ExtrudeSurface" surface curve))
    ((surface curve cap?)
     (rhino-check-invoke "ExtrudeSurface" surface curve cap?))))

(define get-object
  (case-lambda
    ((message)
     (rhino-check-invoke "GetObject" message))
    ((message type)
     (rhino-check-invoke "GetObject" message type))
    ((message type pre-select?)
     (rhino-check-invoke "GetObject" message type pre-select?))
    ((message type pre-select? select?)
     (rhino-check-invoke "GetObject" message type pre-select? select?))
    ((message type pre-select? select? objects)
     (rhino-check-invoke "GetObject" message type pre-select? select? objects))))

(define get-point
  (case-lambda
    ((message)
     (coord-of-vector
      (rhino-check-invoke "GetPoint" message)))
    ((message point)
     (coord-of-vector
      (rhino-check-invoke
       "GetPoint"
       message
       (vector<real><-coord point))))
    ((message point distance)
     (coord-of-vector
      (rhino-check-invoke
       "GetPoint"
       message
       (vector<real><-coord point)
       (real<-number distance))))
    ((message point distance plane?)
     (rhino-check-invoke
      "GetPoint"
      message
      (vector<real><-coord point)
      (real<-number distance)
      plane?))))

(define intersect-breps
  (case-lambda
    ((brep1 brep2)
     (vector->list
      (rhino-check-invoke
       "IntersectBreps"
       brep1
       brep2)))
    ((brep1 brep2 tolerance)
     (vector->list
      (rhino-check-invoke
       "IntersectBreps"
       brep1
       brep2
       (real<-number tolerance))))))

(define (is-circle? object)
  (rhino-check-invoke "IsCircle" object))

(define (is-curve? object)
  (rhino-check-invoke "IsCurve" object))

(define (is-curve-closed? object)
  (rhino-check-invoke "IsCurveClosed" object))

(define is-curve-closable?
  (case-lambda
    ((object)
     (rhino-check-invoke "IsCurveClosable" object))
    ((object tolerance)
     (rhino-check-invoke
      "IsCurveClosable"
      object
      (real<-number tolerance)))))

(define (is-layer? layer)
  (rhino-check-invoke "IsLayer" layer))

(define is-line?
  (case-lambda
    ((object)
     (rhino-check-invoke "IsLine" object))
    ((object index)
     (rhino-check-invoke "IsLine" object index))))

(define (is-object? object)
  (rhino-invoke "IsObject" object))

(define is-object-in-box?
  (case-lambda
    ((object box)
     (rhino-check-invoke
      "IsObjectInBox"
      object
      (flat-vector<real><-bbox box)))
    ((object box mode?)
     (rhino-check-invoke
      "IsObjectInBox"
      object
      (flat-vector<real><-bbox box)
      mode?))))

(define (is-object-solid? object)
  (rhino-check-invoke "IsObjectSolid" object))

(define (is-polycurve? object)
  (rhino-check-invoke "IsPolyCurve" object))

(define (is-polysurface? object)
  (rhino-check-invoke "IsPolysurface" object))

(define (is-point? object)
  (rhino-check-invoke "IsPoint" object))

(define (is-surface? object)
  (rhino-check-invoke "IsSurface" object))

; edit: create an enum for flags
(define (last-created-objects (select? #f) (flags 0))
  (vector->list
   (rhino-check-invoke "LastCreatedObjects" select? flags)))

(define join-curves
  (case-lambda
    ((objects)
     (vector->list
      (rhino-check-invoke
       "JoinCurves"
       (list->vector objects))))
    ((objects delete?)
     (vector->list
      (rhino-check-invoke
       "JoinCurves"
       (list->vector objects)
       delete?)))
    ((objects delete? tolerance)
     (vector->list
      (rhino-check-invoke
       "JoinCurves"
       (list->vector objects)
       delete?
       (real<-number tolerance))))))

(define (join-surfaces objects delete?)
  (rhino-check-invoke
   "JoinSurfaces"
   (list->vector objects)
   delete?))

(define move-object
  (case-lambda
    ((object translation)
     (rhino-check-invoke
      "MoveObject"
      object
      (vector<real><-coord translation)))
    ((object start end)
     (rhino-check-invoke
      "MoveObject"
      object
      (vector<real><-coord start)
      (vector<real><-coord end)))))

(define move-objects
  (case-lambda
    ((objects translation)
     (vector->list
      (rhino-check-invoke
       "MoveObjects"
       (list->vector objects)
       (vector<real><-coord translation))))
    ((objects start end)
     (vector->list
      (rhino-check-invoke
       "MoveObjects"
       (list->vector objects)
       (vector<real><-coord start)
       (vector<real><-coord end))))))

(define (offset-surface object distance)
  (rhino-check-invoke
   "OffsetSurface"
   object
   (real<-number distance)))

(define (plane-from-frame origin x-axis y-axis)
  (matrix<-nested-plane
   (rhino-check-invoke
    "PlaneFromFrame"
    (vector<real><-coord origin)
    (vector<real><-coord x-axis)
    (vector<real><-coord y-axis))))

(define (plane-from-normal origin normal)
  (matrix<-nested-plane
   (rhino-check-invoke
    "PlaneFromNormal"
    (vector<real><-coord origin)
    (vector<real><-coord normal))))

(define (plane-from-points origin point-x point-y)
  (matrix<-nested-plane
   (rhino-check-invoke
    "PlaneFromPoints"
    (vector<real><-coord origin)
    (vector<real><-coord point-x)
    (vector<real><-coord point-y))))

(define point-coordinates
  (case-lambda
    ((object)
     (coord-of-vector
      (rhino-check-invoke "PointCoordinates" object)))
    ((object point)
     (coord-of-vector
      (rhino-check-invoke
       "PointCoordinates"
       object
       (vector<real><-coord point))))))

(define (purge-layer layer)
  (rhino-check-invoke "PurgeLayer" layer))

(define (renane-layer old-name new-name)
  (rhino-check-invoke "RenameLayer" old-name new-name))

(define rotate-object
  (case-lambda
    ((object point angle)
     (rhino-check-invoke
      "RotateObject"
      object
      (vector<real><-coord point)
      (real<-number angle)))
    ((object point angle axis)
     (rhino-check-invoke
      "RotateObject"
      object
      (vector<real><-coord point)
      (real<-number angle)
      (vector<real><-coord axis)))
    ((object point angle axis copy?)
     (rhino-check-invoke
      "RotateObject"
      object
      (vector<real><-coord point)
      (real<-number angle)
      (vector<real><-coord axis)
      copy?))))

(define rotate-objects
  (case-lambda
    ((objects point angle)
     (vector->list
      (rhino-check-invoke
       "RotateObjects"
       (list->vector objects)
       (vector<real><-coord point)
       (real<-number angle))))
    ((objects point angle axis)
     (vector->list
      (rhino-check-invoke
       "RotateObjects"
       (list->vector objects)
       (vector<real><-coord point)
       (real<-number angle)
       (vector<real><-coord axis))))
    ((objects point angle axis copy?)
     (vector->list
      (rhino-check-invoke
       "RotateObjects"
       (list->vector objects)
       (vector<real><-coord point)
       (real<-number angle)
       (vector<real><-coord axis)
       copy?)))))

(define (scale-object object origin scale (copy? #f))
  (rhino-check-invoke
   "ScaleObject"
   object
   (vector<real><-coord origin)
   (vector<real><-coord scale)
   copy?))

(define (scale-objects objects origin scale (copy? #f))
  (vector->list
   (rhino-check-invoke
    "ScaleObjects"
    objects
    (vector<real><-coord origin)
    (vector<real><-coord scale)
    copy?)))

(define (select-object object)
  (rhino-check-invoke "SelectObject" object))

(define (select-objects objects)
  (unless (empty? objects)
    (rhino-check-invoke "SelectObjects" (list->vector objects))))

(define (selected-objects . args)
  (with-handlers ((com-exn? (λ (e) (list))))
    (vector->list
     (match args
       ((list) (rhino-check-invoke "SelectedObjects"))
       ((list include-lights?) (rhino-check-invoke "SelectedObjects" include-lights?))
       ((list include-lights? include-grips?) (rhino-check-invoke "SelectedObjects" include-lights? include-grips?))))))

(define split-brep
  (case-lambda
    ((brep cutter)
     (vector->list
      (rhino-check-invoke "SplitBrep" brep cutter)))
    ((brep cutter delete?)
     (vector->list
      (rhino-check-invoke "SplitBrep" brep cutter delete?)))))

(define (surface-curvature object uv)
  (let ((curvature
         (rhino-check-invoke
          "SurfaceCurvature"
          object
          (vector (real<-number (first uv)) (real<-number (second uv))))))
    (list
     (coord-of-vector (vector-ref curvature 0))
     (coord-of-vector (vector-ref curvature 1))
     (vector-ref curvature 2)
     (coord-of-vector (vector-ref curvature 3))
     (vector-ref curvature 4)
     (coord-of-vector (vector-ref curvature 5))
     (vector-ref curvature 6)
     (vector-ref curvature 7))))

(define (surface-domain object direction)
  (vector->list
   (rhino-check-invoke "SurfaceDomain" object direction)))

; edit: what a very complicated function... is it really necessary?
;; (define (surface-surface-intersection surface-a surface-b (tolerance com-omit) (create? com-omit))
;;   (rhino-check-invoke "SurfaceSurfaceIntersection" surface-a surface-b tolerance create?))


(define sweep1
  (case-lambda
    ((rail shapes)
     ;;Rhino demands the shape to be near (whatever that means)
     ;;to the rail
     (vector->list
      (rhino-check-invoke "AddSweep1" rail (list->vector shapes))))))

(define (transform-object object matrix (copy? #f))
  (rhino-check-invoke-boolean
   "TransformObject"
   object
   (vector (m-line matrix 0)
           (m-line matrix 1)
           (m-line matrix 2)
           (vector 0 0 0 1))
;   (flat-plane<-matrix matrix)
   copy?))
  
(define (transform-objects objects matrix (copy? #f))
  (vector->list
   (rhino-check-invoke
    "TransformObjects"
    (list->vector objects)
    (vector (m-line matrix 0)
            (m-line matrix 1)
            (m-line matrix 2)
            (vector 0 0 0 1))
    ;    (flat-plane<-matrix matrix)
    copy?)))

(define (unselect-all-objects)
  (rhino-invoke "UnselectAllObjects"))

(define (unselect-object object)
  (rhino-check-invoke "UnselectObject" object))

(define (unselect-objects objects)
  (rhino-check-invoke "UnselectObjects" (list->vector objects)))

(define (unselected-objects . args)
  (with-handlers ((com-exn? (λ (e) (list))))
    (vector->list
     (match args
       ((list) (rhino-check-invoke "UnselectedObjects"))
       ((list include-lights?) (rhino-check-invoke "UnselectedObjects" include-lights?))
       ((list include-lights? include-grips?) (rhino-check-invoke "UnselectedObjects" include-lights? include-grips?))))))

(define view-camera-lens
  (case-lambda
    (() (rhino-check-invoke "ViewCameraLens"))
    ((view) (rhino-check-invoke "ViewCameraLens" view))
    ((view length)
     (rhino-check-invoke
      "ViewCameraLens"
      view
      (real<-number length)))))

(define view-camera-target
  (case-lambda
    (() (rhino-check-invoke "ViewCameraTarget"))
    ((view) (rhino-check-invoke "ViewCameraTarget" view))
    ((view camera)
     (list<coord><-vector<vector<real>>
      (rhino-check-invoke
       "ViewCameraTarget"
       view
       (vector<real><-coord camera))))
    ((view camera target)
     (list<coord><-vector<vector<real>>
      (rhino-check-invoke
       "ViewCameraTarget"
       view
       (vector<real><-coord camera)
       (vector<real><-coord target))))))

(define view-display-mode
  (case-lambda
    (() (rhino-check-invoke "ViewDisplayMode"))
    ((view) (rhino-check-invoke "ViewDisplayMode" view))
    ((view mode) (rhino-check-invoke "ViewDisplayMode" view mode))))

(define view-projection
  (case-lambda
    (() (rhino-check-invoke "ViewProjection"))
    ((view) (rhino-check-invoke "ViewProjection" view))
    ((view mode) (rhino-check-invoke "ViewProjection" view mode))))

(define view-radius
  (case-lambda
    (() (rhino-check-invoke "ViewRadius"))
    ((view) (rhino-check-invoke "ViewRadius" view))
    ((view radius)
     (rhino-check-invoke
      "ViewRadius"
      view
      (real<-number radius)))))

(define (view-size)
  (case-lambda
    (() (vector->list (rhino-check-invoke "ViewSize")))
    ((view) (vector->list (rhino-check-invoke "ViewSize" view)))))

(define (world-xy-plane)
  (matrix<-nested-plane
   (rhino-invoke "WorldXYPlane")))

(define (world-yz-plane)
  (matrix<-nested-plane
   (rhino-invoke "WorldYZPlane")))

(define (world-zx-plane)
  (matrix<-nested-plane
   (rhino-invoke "WorldZXPlane")))

(define zoom-extents
  (case-lambda
    (() (rhino-invoke "ZoomExtents"))
    ((view) (rhino-invoke "ZoomExtents" view))
    ((view all?) (rhino-invoke "ZoomExtents" view all?))))

(define zoom-selected
  (case-lambda
    (() (rhino-invoke "ZoomSelected"))
    ((view) (rhino-invoke "ZoomSelected" view))
    ((view all?) (rhino-invoke "ZoomSelected" view all?))))